Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/ptoc/part12

Text File | 1987-07-28 | 62.1 KB | 2,558 lines

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i076:  Pascal to C translator, Part12/12
Message-ID: <[e-mail]>
Date: 30 Jul 87 00:31:10 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 2547
Approved: [e-mail]

Submitted-by: Per Bergsten <mcvax!enea!chalmers!holtec!perb>
Posting-number: Volume 10, Issue 76
Archive-name: ptoc/Part12


#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 12 (of 12)."
# Contents:  ptc.p.1
if test -f 'ptc.p.1' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'ptc.p.1'\"
else
echo shar: Extracting \"'ptc.p.1'\" \(59347 characters\)
sed "s/^X//" >'ptc.p.1' <<'END_OF_FILE'
X(***************************************************************************)
X(***************************************************************************)
X(**                                      **)
X(**    Copyright (C) 1987 by Per Bergsten, Gothenburg, Sweden          **)
X(**                                      **)
X(**    No part of this program, or parts derived from this program,      **)
X(**    may be sold, hired or otherwise exploited without the author's      **)
X(**    written consent.                          **)
X(**                                      **)
X(**    The program may be freely redistributed provided that:          **)
X(**                                      **)
X(**        1) the original program text, including this notice,      **)
X(**           is reproduced unaltered,                  **)
X(**        2) no charge (other than a nominal media cost) is      **)
X(**           demanded for the copy.                  **)
X(**                                      **)
X(**    The program may be included in a package only on the condition      **)
X(**    that the package as a whole is distributed at media cost.      **)
X(**                                      **)
X(***************************************************************************)
X(***************************************************************************)
X(**                                      **)
X(**    The program ptc is a Pascal-to-C translator.              **)
X(**    It accepts a correct Pascal program and creates a C program      **)
X(**    with the same behaviour. It is not a complete compiler in the      **)
X(**    sense that it does NOT do complete typechecking or error-      **)
X(**    reporting. Only a minimal typecheck is done so that the meaning      **)
X(**    of each construct can be determined. Therefore, an incorrect      **)
X(**    Pascal program can easily cause the translator to malfunction.      **)
X(**                                      **)
X(***************************************************************************)
X(***************************************************************************)
X(**                                      **)
X(**    Things which are known to be dependent on the underlying cha-      **)
X(**    racterset are marked with a comment containing the word    CHAR.      **)
X(**    Things that are known to be dependent on the host operating      **)
X(**    system are marked with a comment containing the word OS.      **)
X(**    Things known to be dependent on the cpu and/or the target C-      **)
X(**    implementation are marked with the word CPU.              **)
X(**    Things dependent on the target C-library are marked with LIB.      **)
X(**                                      **)
X(**    The code generated by the translator assumes that there    is a      **)
X(**    C-implementation with at least a reasonable <stdio> library      **)
X(**    since all input/output is implemented in terms of C functions      **)
X(**    like fprintf(), getc(), fopen(), rewind() etc.              **)
X(**    If the source-program uses Pascal functions like sin(), sqrt()      **)
X(**    etc, there must also exist such functions in the C-library.      **)
X(**                                      **)
X(***************************************************************************)
X(***************************************************************************)
X
Xprogram    ptc(input, output);
X
Xlabel    9999;                (* end of program        *)
X
Xconst    version        = '@(#)ptc.p    1.5  Date 87/05/01';
X
X    keytablen    = 38;        (* nr of keywords        *)
X    keywordlen    = 10;        (* length of a keyword        *)
X    othersym    = 'otherwise '; (* keyword for others        *)
X    externsym    = 'external  '; (* keyword for external        *)
X    dummysym    = '          '; (* dummy keyword        *)
X
X    (* a Pascal set is implemented as an array of "wordtype" where    *)
X    (* each element contains bits numbered from 0 to "setbits"    *)
X    wordtype    = 'unsigned short';    (* CPU *)
X    setbits        = 15;            (* CPU *)
X
X    (* a Pascal file is implemented as a struct which (among other    *)
X    (* things) contain a flag-field, currently 3 bits are used    *)
X    filebits    = 'unsigned short';    (* flags for files    *)
X    filefill    = 12;            (* 16 less used 3 bits    *)
X
X    maxsetrange    = 15;            (* nr of words in a set    *)
X    scalbase    = 0;    (* ordinal value of first scalar member    *)
X
X    maxprio        = 7;
X
X    maxmachdefs    = 8;    (* max nr of machine integer types    *)
X    machdeflen    = 16;    (* max length of machine int type name    *)
X
X    (* limit of identifier table, identifiers and strings are saved    *)
X    (* in an array 0 .. maxblkcnt of ^ array 0 .. maxstrblk of char    *)
X    maxstrblk    = 1023;
X    maxblkcnt    = 63;
X    maxstrstor    = 65535; (* maxstrstor should be ==
X                    (maxblkcnt+1) * (maxstrblk+1) - 1 *)
X
X    maxtoknlen    = 127;    (* max size of token (i.e. identifier,
X                   string or number); must be > keywordlen
X                   and should be <= 256, see hashtokn()    *)
X
X    hashmax        = 64;    (* size of hashtable - 1        *)
X
X    null        = 0;    (* "impossible" character value, CHAR;
X                   a char with this value is used as delimiter
X                   of strings in "strstor" and in toknbuffers;
X                   it is also used as end-of-input marker by
X                   the input procedures in lexical analysis *)
X
X    minchar        = null;
X    maxchar        = 127;    (* greatest possible character, CHAR; limits
X                   the number of elements in type "char" *)
X
X    (* tmpfilename is used in the generated code to obtain names of
X       temporary files for reset/rewrite, the last character is supplied
X       by the reset/rewrite routine *)
X    tmpfilename    = '"/tmp/ptc%d%c", getpid(), '; (* OS *)
X
X    (* some frequently used characters *)
X    space        = ' ';
X    tab1        = '    ';
X    tab2        = '        ';
X    tab3        = '            ';
X    tab4        = '                ';
X    bslash        = '\';
X    nlchr        = '''\n''';
X    ffchr        = '''\f''';
X    nulchr        = '''\0''';
X    spchr        = ''' ''';
X    quote        = '''';
X    cite        = '"';
X    xpnent        = 'e';        (* exponent char in output. CPU    *)
X    percent        = '%';
X    uscore        = '_';
X    badchr        = '?';        (* CHAR *)
X    okchr        = quote;    (* CHAR *)
X
X    tabwidth    = 8;        (* width of a tab-stop. OS    *)
X
X    echo        = false;     (* echo input as read        *)
X    diffcomm    = false;     (* comment delimiters different    *)
X    lazyfor        = false;     (* compile for-stmts a la C    *)
X    unionnew    = true;     (* malloc unions for variants    *)
X
X    inttyp        = 'int';    (* for predefined functions    *)
X    chartyp        = 'char';
X    setwtyp        = 'setword';
X    setptyp        = 'setptr';
X    floattyp    = 'float';
X    doubletyp    = 'double';
X    dblcast        = '(double)';    (* for predefined functions    *)
X
X    realtyp        = doubletyp;    (* user real-vars and functions    *)
X
X    voidtyp        = 'void';    (* for procedures         *)
X    voidcast    = '(void)';
X
X    intlen        = 10;        (* length of written integer    *)
X    fixlen        = 20;        (* length of written real    *)
X
Xtype
X    hashtyp    = 0 .. hashmax;        (* index to hash-tables    *)
X
X    strindx    = 0 .. maxstrstor;    (* index to "strstor"        *)
X
X    (* string-table "strstor" is implemented as an array that is grown
X       dynamically by adding blocks when needed *)
X    strbidx    = 0 .. maxstrblk;
X    strblk    = array [ strbidx ] of char;
X    strptr    = ^ strblk;
X    strbcnt    = 0 .. maxblkcnt;
X
X    (* table for stored identifiers *)
X    (* an identifier in any scope is represented by an idnode which is
X       hooked to a slot in "idtab" as determined by a hash-function.
X       whenever the input procedures find an identifier its idnode is
X       immediately located, or created, if none was found; the identifier
X       is then always handled though a pointer to the idnode. the actual
X       text of the identifier is stored in "strstor". *)
X    idptr    = ^ idnode;
X    idnode    = record
X            inext    : idptr;    (* chain of idnode's    *)
X            inref    : 0 .. 127;    (* # of refs to this id    *)
X            ihash    : hashtyp;    (* its hash value    *)
X            istr    : strindx;    (* index to "strstor"    *)
X          end;
X
X    (* toknbuf is used to handle identifiers and strings in those situations
X       where the actual text is of intrest *)
X    toknidx    = 1 .. maxtoknlen;
X    toknbuf    = array [ toknidx ] of char;
X
X    (* a type to hold Pascal keywords *)
X    keyword    = packed array [ 1 .. keywordlen ] of char;
X
X    (* predefined identifier enumeration *)
X    predefs = (
X        dabs,        darctan,    dargc,        dargv,
X        dboolean,    dchar,        dchr,        dclose,
X        dcos,        ddispose,    deof,        deoln,
X        dexit,        dexp,        dfalse,        dflush,
X        dget,        dhalt,        dinput,        dinteger,
X        dln,        dmaxint,    dmessage,    dnew,
X        dodd,        dord,        doutput,    dpage,
X        dpack,        dpred,        dput,        dread,
X        dreadln,    dreal,        dreset,        drewrite,
X        dround,        dsin,        dsqr,        dsqrt,
X        dsucc,        dtext,        dtrue,        dtrunc,
X        dtan,        dwrite,        dwriteln,    dunpack,
X        dzinit,        dztring
X    );
X
X    (* lexical symbol enumeration *)
X    symtyp    = (
X        (* keywords and eof are sorted alphabetically ...... *)
X        sand,        sarray,        sbegin,        scase,
X        sconst,        sdiv,        sdo,        sdownto,
X        selse,        send,        sextern,    sfile,
X        sfor,        sforward,    sfunc,        sgoto,
X        sif,        sinn,        slabel,        smod,
X        snil,        snot,        sof,        sor,
X        sother,        spacked,    sproc,        spgm,
X        srecord,    srepeat,    sset,        sthen,
X        sto,        stype,        suntil,        svar,
X        swhile,        swith,        seof,
X        (* ...... sorted *)
X                                sinteger,
X        sreal,        sstring,    schar,        sid,
X        splus,        sminus,        smul,        squot,
X        sarrow,        slpar,        srpar,        slbrack,
X        srbrack,    seq,        sne,        slt,
X        sle,        sgt,        sge,        scomma,
X        scolon,        ssemic,        sassign,    sdotdot,
X        sdot
X    );
X    symset    = set of symtyp;
X
X    (* lexical symbol definition *)
X    (* the lexical symbol holds a descriptor and the value of a symbol
X       read by the input procedures; note that real values are represented
X       as strings saved in "strstor" like ordinary strings to avoid using
X       float-variables and float-arithmetic in the translator *)
X    lexsym    =
X        record
X        case st : symtyp of
X          sid:        (vid    : idptr);
X          schar:    (vchr    : char);
X          sinteger:    (vint    : integer);
X          sreal:    (vflt    : strindx);
X          sstring:    (vstr    : strindx);
X        end;
X
X    (* enumeration of symnode variants *)
X    ltypes = (
X        lpredef,    lidentifier,    lfield,        lforward,
X        lpointer,    lstring,    llabel,        lforwlab,
X        linteger,    lreal,        lcharacter
X    );
X
X    declptr    = ^ declnode;
X    treeptr    = ^ treenode;
X    symptr    = ^ symnode;
X    (* identifier/literal symbol definition *)
X    (* in a given scope an identifier or a label is uniquely represented
X       by a "symnode"; in order to have a uniform treatment of all objects
X       occurring in the same syntactical positions (and hence in the parse-
X       tree) the literal constants are represented in a similar manner *)
X    symnode    =
X        record
X        lsymdecl    : treeptr;    (* symbol decl. point    *)
X        lnext        : symptr;    (* symtab chain pointer    *)
X        ldecl        : declptr;    (* backptr to symtab    *)
X        case lt : ltypes of
X          lpredef,            (* a predefined id    *)
X          lfield,            (* a record field    *)
X          lpointer,            (* a pointer id        *)
X          lidentifier,            (* an identifier    *)
X          lforward:
X            (
X            lid    : idptr;    (* ptr to its idnode    *)
X            lused    : boolean    (* true if symbol used    *)
X            );
X          lstring:            (* a string literal     *)
X            (
X            lstr    : strindx    (* index to "strstor"    *)
X            );
X          lreal:            (* a real literal    *)
X            (
X            lfloat    : strindx    (* index to "strstor"    *)
X            );
X          lforwlab,            (* a declared label    *)
X          llabel:            (* label decl & defined    *)
X            (
X            lno    : integer;    (* label number        *)
X            lgo    : boolean    (* non-local usage    *)
X            );
X          linteger:            (* an integer literal    *)
X            (
X            linum    : integer    (* its value        *)
X            );
X          lcharacter:            (* a character literal    *)
X            (
X            lchar    : char        (* its value        *)
X            )
X        end;
X
X    (* symbol table definition *)
X    (* the symbol table consists of symnodes chained along the lnext
X       field; the nodes are connected in reverse order of occurence (last
X       declared, first in chain) in the slot in the declnode determined
X       by the hashfunction; when a new scope is entered a new declnode is
X       manufactured and the previous one is hooked to the dprev field, thus
X       nested scopes are represented by a list of declnodes *)
X    declnode = record
X            dprev    : declptr;
X            ddecl    : array [ hashtyp ] of symptr
X           end;
X
X    (* enumeration of nodes in parse tree *)
X    (* NOTE: the subrange [ assignment .. nil ]  have priorities *)
X    treetyp    = (
X        npredef,    npgm,        nfunc,        nproc,
X        nlabel,        nconst,        ntype,        nvar,
X        nvalpar,    nvarpar,    nparproc,    nparfunc,
X        nsubrange,    nvariant,    nfield,        nrecord,
X        narray,        nconfarr,    nfileof,    nsetof,
X        nbegin,        nptr,        nscalar,    nif,
X        nwhile,        nrepeat,    nfor,        ncase,
X        nchoise,    ngoto,        nwith,        nwithvar,
X        nempty,        nlabstmt,    nassign,    nformat,
X        nin,        neq,        nne,        nlt,
X        nle,        ngt,        nge,        nor,
X        nplus,        nminus,        nand,        nmul,
X        ndiv,        nmod,        nquot,        nnot,
X        numinus,    nuplus,        nset,        nrange,
X        nindex,        nselect,    nderef,        ncall,
X        nid,        nchar,        ninteger,    nreal,
X        nstring,    nnil,        npush,        npop,
X        nbreak
X    );
X
X    (* enumeration of predefined types *)
X    pretyps = (
X        tnone,        tboolean,    tchar,        tinteger,
X        treal,        tstring,    tnil,        tset,
X        ttext,        tpoly,        terror
X    );
X
X    (* enumeration of some special attributes *)
X    attributes = (
X        anone, aregister, aextern, areference
X    );
X
X    (* parse tree definition *)
X    (* the sourceprogram is represented by a treestructure built from
X       treenodes where each node corresponds to one syntactic form from
X       the pascal program *)
X    treenode =
X        record
X        tnext,            (* ptr to next node in a list    *)
X        ttype,            (* pointer to nodes type    *)
X        tup    : treeptr;    (* ptr to parent node        *)
X        case tt : treetyp of
X          npredef:        (* predefined object decl    *)
X            (
X            tdef:        (* predefined object descr.    *)
X                predefs;
X            tobtyp:        (* object type            *)
X                pretyps
X            );
X          npgm,            (* program declaration        *)
X          nproc,        (* procedure declaration    *)
X          nfunc:        (* function declaration        *)
X            (
X            tsubid,        (* subr. identifier (nid)    *)
X            tsubpar,    (* parameter list        *)
X            tfuntyp,    (* function type (nid)        *)
X            tsublab,    (* label decl list (nlabel)    *)
X            tsubconst,    (* const decl list (nconst)    *)
X            tsubtype,    (* type decl list (ntype)    *)
X            tsubvar,    (* var decl list (nvar)        *)
X            tsubsub,    (* subr. decl (nproc/nfunc)    *)
X            tsubstmt:    (* stmt. list (NOT nbegin)    *)
X                treeptr;
X            tstat:        (* static declaration level    *)
X                integer;
X            tscope:        (* symbol table for local id's    *)
X                 declptr
X            );
X          nvalpar,        (* value parameter declaration    *)
X          nvarpar,        (* var parameter declaration    *)
X          nconst,        (* constant declaration        *)
X          ntype,        (* type declaration        *)
X          nfield,        (* record field declaration    *)
X          nvar:            (* var declaration declaration    *)
X            (
X            tidl,        (* list of declared id's (nid)    *)
X            tbind:        (* var/type-type, const-value    *)
X                treeptr;
X            tattr:        (* special attributes for vars    *)
X                attributes
X            );
X          nparproc,        (* parameter procedure        *)
X          nparfunc:        (* parameter function        *)
X            (
X            tparid,        (* parm proc/func id (nid)    *)
X            tparparm,    (* parm proc/func parm decl    *)
X            tpartyp:    (* parm func type (nid)        *)
X                treeptr
X            );
X          nptr:            (* pointer constructor        *)
X            (
X            tptrid:        (* referenced type (nid)    *)
X                treeptr;
X            tptrflag:    (* have seen node before    *)
X                boolean
X            );
X          nscalar:        (* scalar type constructor    *)
X            (
X            tscalid:    (* list of scalar ids (nid)    *)
X                treeptr
X            );
X          nfileof,        (* file type constructor    *)
X          nsetof:        (* set type constructor        *)
X            (
X            tof:        (* set/file component type    *)
X                treeptr
X            );
X          nsubrange:        (* subrange type constructor    *)
X            (
X            tlo, thi:    (* subrange limits        *)
X                treeptr
X            );
X          nvariant:        (* record variant constructor    *)
X            (
X            tselct,        (* selector list (constants)    *)
X            tvrnt:        (* variant field decl (nrecord)    *)
X                treeptr
X            );
X
X        (* the tuid field is used to attach a name to variants since
X           C requires all union members to have names *)
X          nrecord:        (* record/variant constructor    *)
X            (
X            tflist,        (* fixed field list (nfield)    *)
X            tvlist:        (* variant list (nvariant)    *)
X                treeptr;
X            tuid:        (* variant name            *)
X                idptr;
X            trscope:    (* symbol table for local id's    *)
X                 declptr
X            );
X          nconfarr:        (* conformant array constructor    *)
X            (
X            tcindx,        (* index declaration        *)
X            tindtyp,    (* conf. arr. index type (nid)    *)
X            tcelem:        (* array element type decl    *)
X                treeptr;
X            tcuid:        (* variant name            *)
X                idptr
X            );
X          narray:        (* array type constructor    *)
X            (
X            taindx,        (* index declaration        *)
X            taelem:        (* array element type decl    *)
X                treeptr
X            );
X          nbegin:        (* begin statement        *)
X            (
X            tbegin:        (* statement list        *)
X                treeptr
X            );
X          nlabstmt:        (* labeled statement        *)
X            (
X            tlabno,        (* label number (nlabel)    *)
X            tstmt:        (* statement            *)
X                treeptr
X            );
X          ngoto:        (* goto statement        *)
X            (
X            tlabel:        (* label to go to (nlabel)    *)
X                treeptr
X            );
X
X          nassign:        (* assignment statement        *)
X            (
X            tlhs,        (* variable            *)
X            trhs:        (* value            *)
X                treeptr
X            );
X
X        (* npush/npop is used in proc/func which have local variables
X           used in local proc/funcs; those variables are converted to
X           global ptrs initialized to reference the local variable *)
X          npush,        (* init code for proc/func    *)
X          npop:            (* exit code for proc/func    *)
X            (
X            tglob,        (* global identifier (nid)    *)
X            tloc,        (* local identifier (nid)    *)
X            ttmp:        (* temp store for global (nid)    *)
X                treeptr
X            );
X
X          nbreak:
X            (
X            tbrkid,        (* for-variable            *)
X            tbrkxp:        (* value for break        *)
X                treeptr
X            );
X
X          ncall:        (* procedure/function call    *)
X            (
X            tcall,        (* called identifier        *)
X            taparm:        (* actual paramters        *)
X                treeptr
X            );
X          nif:            (* if statement            *)
X            (
X            tifxp,        (* conditional expression    *)
X            tthen,        (* stmt execd if true condition    *)
X            telse:        (* stmt execd if true condition    *)
X                treeptr
X            );
X          nwhile:        (* while statemnet        *)
X            (
X            twhixp,        (* conditional expression    *)
X            twhistmt:    (* stmt execd if true condition    *)
X                treeptr
X            );
X          nrepeat:        (* repeat statement        *)
X            (
X            treptstmt,    (* statement list        *)
X            treptxp:    (* conditional expression    *)
X                treeptr
X            );
X          nfor:            (* for statement        *)
X            (
X            tforid,        (* loop control variable (nid)    *)
X            tfrom,        (* initial value        *)
X            tto,        (* final value            *)
X            tforstmt:    (* stmt execd in loop        *)
X                treeptr;
X            tincr:        (* to/downto flag true <==> to    *)
X                boolean
X            );
X          ncase:        (* case statement        *)
X            (
X            tcasxp,        (* selecting expression        *)
X            tcaslst,    (* list of choises        *)
X            tcasother:    (* default action        *)
X                treeptr
X            );
X          nchoise:        (* a choise in a case-stmt    *)
X            (
X            tchocon,    (* list of constants        *)
X            tchostmt:    (* execd statement        *)
X                treeptr
X            );
X          nwith:        (* with statment        *)
X            (
X            twithvar,    (* list of variables (nwithvar)    *)
X            twithstmt:    (* statement execd in new scope    *)
X                treeptr
X            );
X
X        (* the local symbol table holds identifiers, picked from
X           the record fields, temporarily declared during parsing
X           of remainder of with-statement; these identifiers are
X           later converted into fields referenced through a ptr *)
X          nwithvar:        (* variable in with statement    *)
X            (
X            texpw:        (* record variable        *)
X                treeptr;
X            tenv:        (* symbol table for local scope    *)
X                declptr
X            );
X
X          nindex:        (* array indexing expression    *)
X            (
X            tvariable,    (* indexed variable        *)
X            toffset:    (* index expression        *)
X                treeptr
X            );
X          nselect:        (* record field selection expr    *)
X            (
X            trecord,    (* record variable        *)
X            tfield:        (* selected field (nid)        *)
X                treeptr
X            );
X
X        (* binary operators or constructors *)
X          nrange,        (* .. (set range)    *)
X          nformat,        (* :  (write format)    *)
X          nin,            (* in            *)
X          neq,            (* =            *)
X          nne,            (* <>            *)
X          nlt,            (* <            *)
X          nle,            (* <=            *)
X          ngt,            (* >            *)
X          nge,            (* >=            *)
X          nor,            (* or            *)
X          nplus,        (* +            *)
X          nminus,        (* -            *)
X          nand,            (* and            *)
X          nmul,            (* *            *)
X          ndiv,            (* div            *)
X          nmod,            (* mod            *)
X          nquot:        (* /            *)
X            (
X            texpl,        (* left operand expr    *)
X            texpr:        (* right operand expr    *)
X                treeptr
X            );
X
X        (* unary operators or constructors; note that uplus is
X           used to represent any parenthesized expression *)
X          nderef,        (* ^ (ptr dereference)    *)
X          nnot,            (* not            *)
X          nset,            (* [ ] (set constr)    *)
X          nuplus,        (* +            *)
X          numinus:        (* -            *)
X            (
X            texps:        (* operand expression    *)
X                treeptr
X            );
X
X          nid,            (* identifier in decl or stmt    *)
X          nreal,        (* literal real (decl or stmt)    *)
X          ninteger,        (* literal int ( - " - )    *)
X          nchar,        (* literal char ( - " - )    *)
X          nstring,        (* literal string ( - " - )    *)
X          nlabel:        (* label (decl, defpt or use)    *)
X            (
X            tsym:
X                symptr
X            );
X
X          nnil,            (* nil (pointer constant)    *)
X          nempty:        (* empty statement        *)
X            ( );
X        end;
X
X    (* "reserved" words and standard identifiers from C, C LIB and
X        OS environment excluding those reserved in Pascal *)
X    cnames = (
X        cabort,        cbreak,        ccontinue,    cdefine,
X        cdefault,    cdouble,    cedata,        cenum,
X        cetext,        cextern,    cfgetc,        cfclose,
X        cfflush,    cfloat,        cfloor,        cfprintf,
X        cfputc,        cfread,        cfscanf,    cfwrite,
X        cgetc,        cgetpid,    cint,        cinclude,
X        clong,        clog,        cmain,        cmalloc,
X        cprintf,    cpower,        cputc,        cread,
X        creturn,    cregister,    crewind,    cscanf,
X        csetbits,    csetword,    csetptr,    cshort,
X        csigned,    csizeof,    csprintf,    cstdin,
X        cstdout,    cstderr,    cstrncmp,    cstrncpy,
X        cstruct,    cstatic,    cswitch,    ctypedef,
X        cundef,        cungetc,    cunion,        cunlink,
X        cunsigned,    cwrite
X    );
X
X    (* these are the detected errors. some are user-errors,
X       some are internal problems and some are host system errors *)
X    errors    = (
X        ebadsymbol,    elongstring,    elongtokn,    erange,
X        emanytokn,    enotdeclid,    emultdeclid,    enotdecllab,
X        emultdecllab,    emuldeflab,    ebadstring,    enulchr,
X        ebadchar,    eeofcmnt,    eeofstr,    evarpar,
X        enew,        esetbase,    esetsize,    eoverflow,
X        etree,        etag,        euprconf,    easgnconf,
X        ecmpconf,    econfconf,    evrntfile,    evarfile,
X        emanymachs,    ebadmach
X    );
X
X    machdefstr = packed array [ 1 .. machdeflen ] of char;
X
Xvar
X    usemax,            (* program needs max-function        *)
X    usejmps,        (* source program uses non-local gotos    *)
X    usecase,        (* source program has case-statement    *)
X    usesets,        (* source program uses set-operations    *)
X    useunion,
X    usediff,
X    usemksub,
X    useintr,
X    usesge,
X    usesle,
X    useseq,
X    usesne,
X    usememb,
X    useins,
X    usescpy,
X    usecomp,        (* source program uses string-compare    *)
X    usefopn,        (* source program uses reset/rewrite    *)
X    usescan,
X    usegetl,
X    usenilp,        (* source program uses nil-pointer     *)
X    usebool    : boolean;    (* source program writes boolean-values    *)
X
X    top    : treeptr;    (* top of parsetree, result from parse    *)
X
X    setlst    : treeptr;    (* list of set-initializations        *)
X    setcnt    : integer;    (* counter for setlst length        *)
X
X    currsym    : lexsym;    (* current lexical symbol        *)
X
X    keytab    : array [ 0 .. keytablen ] of    (* table of keywords    *)
X            record
X            wrd    : keyword;    (* keyword text        *)
X            sym    : symtyp    (* corresponding symbol    *)
X            end;
X
X    strstor    : array [ strbcnt ] of strptr;    (* store for strings    *)
X    strfree    : strindx;            (* first free position    *)
X    strleft    : strbidx;            (* room in last blk    *)
X
X    idtab    : array [ hashtyp ] of idptr;    (* hashed table of id's    *)
X
X    symtab    : declptr;            (* table of symbols    *)
X
X    statlvl,                (* static decl. level    *)
X    maxlevel : integer;            (*  - " - maximum value    *)
X
X    deftab    : array [ predefs ] of treeptr;    (* predefined idents.    *)
X    defnams    : array [ predefs ] of symptr;    (*        - " -        *)
X    typnods    : array [ pretyps ] of treeptr;    (* predef. types.    *)
X
X    pprio,
X    cprio    : array [ nassign .. nnil ] of 0 .. maxprio;
X
X    ctable    : array [ cnames ] of idptr;    (* table of C-keywords    *)
X
X    nmachdefs : 0 .. maxmachdefs;
X    machdefs : array [ 1 .. maxmachdefs ] of (* table of C-types    *)
X            record
X                lolim, hilim    : integer;
X                typstr        : strindx
X            end;
X
X    lineno,                    (* input line number    *)
X    colno,                    (* input column number    *)
X    lastcol,                (* last OK input column    *)
X    lastline : integer;            (* last OK input line    *)
X
X    lasttok    : toknbuf;            (* last input token    *)
X
X    varno    : integer;        (* counter for unique id's    *)
X
X    hexdig    : packed array [ 0 .. 15 ] of char;
X
X(*    Prtmsg produces an error message. It asssumes that procedure    *)
X(*    "message" (predefined) will "writeln" to user tty. OS        *)
Xprocedure prtmsg(m : errors);
X
Xconst    user    = 'Error: ';
X    restr    = 'Implementation restriction: ';
X    inter    = '* Internal error * ';
X    xtoklen    = 64;                (* should be <= maxtoklen *)
X
Xvar    i    : toknidx;
X    xtok    : packed array [ 1 .. xtoklen ] of char;
X
Xbegin
X    case m of
X      ebadsymbol:
X        message(user, 'Unexpected symbol');
X      ebadchar:
X        message(user, 'Bad character');
X      elongstring:
X        message(restr, 'Too long string');
X      ebadstring:
X        message(user, 'Newline in string or character');
X      eeofstr:
X        message(user, 'End of file in string or character');
X      eeofcmnt:
X        message(user, 'End of file in comment');
X      elongtokn:
X        message(restr, 'Too long identfier');
X      emanytokn:
X        message(restr, 'Too many strings, identifiers or real numbers');
X      enotdeclid:
X        message(user, 'Identifier not declared');
X      emultdeclid:
X        message(user, 'Identifier declared twice');
X      enotdecllab:
X        message(user, 'Label not declared');
X      emultdecllab:
X        message(user, 'Label declared twice');
X      emuldeflab:
X        message(user, 'Label defined twice');
X      evarpar:
X        message(user, 'Actual parameter not a variable');
X      enulchr:
X        message(restr, 'Cannot handle nul-character in strings');
X      enew:
X        message(restr, 'New returned a nil-pointer');
X      eoverflow:
X        message(restr, 'Token buffer overflowed');
X      esetbase:
X        message(restr, 'Cannot handle sets with base >> 0');
X      esetsize:
X        message(restr, 'Cannot handle sets with very large range');
X      etree:
X        message(inter, 'Bad tree structure');
X      etag:
X        message(inter, 'Cannot find tag');
X      evrntfile:
X        message(restr, 'Cannot initialize files in record variants');
X      evarfile:
X        message(restr, 'Cannot handle files in structured variables');
X      euprconf:
X        message(inter, 'No upper bound on conformant arrays');
X      easgnconf:
X        message(inter, 'Cannot assign conformant arrays');
X      ecmpconf:
X        message(inter, 'Cannot compare conformant arrays');
X      econfconf:
X        message(restr, 'Cannot handle nested conformat arrays');
X      erange:
X        message(inter, 'Cannot find C-type for integer-subrange');
X      emanymachs:
X        message(restr, 'Too many machine integer types');
X      ebadmach:
X        message(inter, 'Bad name for machine integer type');
X    end;(* case *)
X    if lastline <> 0 then
X        begin
X        (* error detected during parsing,
X            report line/column and print the offending symbol *)
X        message('Line ', lastline:1, ', col ', lastcol:1, ':');
X        if m in [enulchr, ebadchar, ebadstring, ebadsymbol,
X            emuldeflab, emultdecllab, enotdecllab, emultdeclid,
X            enotdeclid, elongtokn, elongstring] then
X            begin
X            i := 1;
X            while (i < xtoklen) and (lasttok[i] <> chr(null)) do
X                begin
X                xtok[i] := lasttok[i];
X                i := i + 1
X                end;
X            while i < xtoklen do
X                begin
X                xtok[i] := ' ';
X                i := i + 1
X                end;
X            xtok[xtoklen] := ' ';
X            message('Current symbol: ', xtok)
X            end
X        end
Xend;
X
Xprocedure fatal(m : errors);    forward;
Xprocedure error(m : errors);    forward;
X
X(*    Map letters to upper-case.                    *)
X(*    This function assumes a machine collating sequence where the    *)
X(*    letters of either case form a contigous sequence, CHAR.    *)
Xfunction uppercase(c : char) : char;
X
Xbegin
X    if (c >= 'a') and (c <= 'z') then
X        uppercase := chr(ord(c) + ord('A') - ord('a'))
X    else
X        uppercase := c
Xend;
X
X
X(*    Map letters to lower-case.                    *)
X(*    This function assumes a machine collating sequence where the    *)
X(*    letters of either case form a contigous sequence, CHAR.    *)
Xfunction lowercase(c : char) : char;
X
Xbegin
X    if (c >= 'A') and (c <= 'Z') then
X        lowercase := chr(ord(c) - ord('A') + ord('a'))
X    else
X        lowercase := c
Xend;
X
X(*    Retrieve a string from strstor.                *)
Xprocedure gettokn(i : strindx; var t : toknbuf);
X
Xvar    c    : char;
X    k    : toknidx;
X    j    : strbidx;
X    p    : strptr;
X
Xbegin
X    k := 1;
X    (* compute block and offset in block *)
X    p := strstor[i div (maxstrblk + 1)];
X    j := i mod (maxstrblk + 1);
X    (* retrieve text up to null *)
X    repeat
X        c := p^[j];
X        t[k] := c;
X        j := j + 1;
X        k := k + 1;
X        if k = maxtoknlen then
X            begin
X            c := chr(null);
X            t[maxtoknlen] := chr(null);
X            prtmsg(eoverflow)
X            end
X    until    c = chr(null)
Xend;
X
X(*    Deposit a string into strstor at a given start-position.    *)
Xprocedure puttokn(i : strindx; var t : toknbuf);
X
Xvar    c    : char;
X    k    : toknidx;
X    j    : strbidx;
X    p    : strptr;
X
Xbegin
X    k := 1;
X    p := strstor[i div (maxstrblk + 1)];
X    j := i mod (maxstrblk + 1);
X    repeat
X        c := t[k];
X        p^[j] := c;
X        k := k + 1;
X        j := j + 1
X    until    c = chr(null)
Xend;
X
X(*    Write a token on standard output.                *)
Xprocedure writetok(var w : toknbuf);
X
Xvar    j    : toknidx;
X
Xbegin
X    j := 1;
X    while w[j] <> chr(null) do
X        begin
X        write(w[j]);
X        j := j + 1
X        end
Xend;
X
X(*    Print a float number on standard output.            *)
Xprocedure printtok(i : strindx);
X
Xvar    w    : toknbuf;
X
Xbegin
X    gettokn(i, w);
X    writetok(w)
Xend;
X
X(*    Print an identifier on standard output.                *)
Xprocedure printid(ip : idptr);
X
Xbegin
X    printtok(ip^.istr)
Xend;
X
X(*    Print a character on standard output with proper C-quoting.    *)
Xprocedure printchr(c : char);
X
Xbegin
X    if (c = quote) or (c = bslash) then
X        write(quote, bslash, c, quote)
X    else
X        write(quote, c, quote)
Xend;
X
X(*    Print a string on standard output with proper C-quoting.    *)
Xprocedure printstr(i : strindx);
X
Xvar    k    : toknidx;
X    c    : char;
X    w    : toknbuf;
X
Xbegin
X    gettokn(i, w);
X    write(cite);
X    k := 1;
X    while w[k] <> chr(null) do
X        begin
X        c := w[k];
X        k := k + 1;
X        if (c = cite) or (c = bslash) then
X            write(bslash);
X        write(c)
X        end;
X    write(cite)
Xend;
X
X(*    Return a pointer to the declarationpoint of an identifier.    *)
Xfunction idup(ip : treeptr) : treeptr;
X
Xbegin
X    idup := ip^.tsym^.lsymdecl^.tup
Xend;
X
X(*    Compute a hashvalue for an identifier or a string.        *)
Xfunction hashtokn(var id : toknbuf) : hashtyp;
X
Xvar    h    : integer;
X    i    : toknidx;
X
Xbegin
X    i := 1;
X    h := 0;
X    while id[i] <> chr(null) do
X        begin
X        (* if ord() of a character ranges from 0 to 127 then we can loop
X           256 times without causing h to exceed 32767, this is safe as
X           both strings and identifiers are limited in length *)
X        h := h + ord(id[i]);    (* CHAR, CPU *)
X        i := i + 1
X        end;
X    hashtokn := h mod hashmax
Xend;
X
X(*    Global string table update.                    *)
X(*    This function accepts a string and stores it in strstor.    *)
X(*    It returns the id-number for the new string.            *)
Xfunction savestr(var t : toknbuf) : strindx;
X
Xvar    k    : toknidx;
X    i    : strindx;
X    j    : strbcnt;
X
Xbegin
X    (* find length of new string including null-char *)
X    k := 1;
X    while t[k] <> chr(null) do
X        k := k + 1;
X    if k > strleft then
X        begin
X        (* out of space in strstore *)
X        if strstor[maxblkcnt] <> nil then    (* last slot used *)
X            error(emanytokn);
X        (* allocate a new block *)
X        j := (strfree + maxstrblk) div (maxstrblk + 1);
X        new(strstor[j]);
X        if strstor[j] = nil then
X            error(enew);
X        strfree := j * (maxstrblk + 1);
X        strleft := maxstrblk
X        end;
X    (* copy new str, update location of last used cell,
X       return starting location for new str *)
X    i := strfree;
X    strfree := strfree + k;
X    strleft := strleft - k;
X    puttokn(i, t);
X    savestr := i
Xend;
X
X(*    Global id table lookup.                        *)
X(*    This procedure accepts an identifier and determines if it has    *)
X(*    been seen before. If that is the case a pointer to its idnode    *)
X(*    is returned, otherwise the identifier is saved and a pointer to    *)
X(*    a new node is returned.                        *)
Xfunction saveid(var id : toknbuf) : idptr;
X
Xlabel    999;
X
Xvar    k    : toknidx;
X    ip    : idptr;
X    h    : hashtyp;
X    t    : toknbuf;
X
Xbegin
X    h := hashtokn(id);
X    ip := idtab[h];                (* scan hashlist for id    *)
X    while ip <> nil do
X        begin
X        gettokn(ip^.istr, t);        (* look at saved token    *)
X        k := 1;
X        while id[k] = t[k] do
X            if id[k] = chr(null) then
X                goto 999    (* found it!        *)
X            else
X                k := k + 1;    (* look at next char    *)
X        ip := ip^.inext
X        end;
X
X    (* identifier wasn't previously seen, manufacture a new idnode,
X       save index to strstor and hashvalue, insert idnode in idtab *)
X    new(ip);
X    if ip = nil then
X        error(enew);
X    ip^.inref := 0;
X    ip^.istr := savestr(id);
X    ip^.ihash := h;
X    ip^.inext := idtab[h];
X    idtab[h] := ip;
X
X999:
X    (* return the idnode *)
X    saveid := ip
Xend;
X
X(*    This function creates a new variable by concatenating one name    *)
X(*    with another injecting a given separator.            *)
Xfunction mkconc(sep : char; p, q : idptr) : idptr;
X
Xvar    w, x    : toknbuf;
X    i, j    : toknidx;
X
Xbegin
X    (* fetch second part and determine its length *)
X    gettokn(q^.istr, x);
X    j := 1;
X    while x[j] <> chr(null) do
X        j := j + 1;
X    (* fetch first part and locate its end *)
X    w[1] := chr(null);
X    if p <> nil then
X        gettokn(p^.istr, w);
X    i := 1;
X    while w[i] <> chr(null) do
X        i := i + 1;
X    (* check total length *)
X    if i + j + 2 >= maxtoknlen then
X        error(eoverflow);
X
X    (* add separators *)
X    if sep = '>' then
X        begin
X        (* special case 1: > gives arrow: a->b *)
X        w[i] := '-';
X        i := i + 1
X        end;
X    if sep <> space then
X        begin
X        (* special case 2: space gives nothing: ab *)
X        w[i] := sep;
X        i := i + 1
X        end;
X    (* add second part *)
X    j := 1;
X    repeat
X        w[i] := x[j];
X        i := i + 1;
X        j := j + 1
X    until w[i-1] = chr(null);
X    (* save new identifier *)
X    mkconc := saveid(w)
Xend;
X
X(*    Create a new id with name-prefix from w.            *)
Xfunction mkuniqname(var t : toknbuf) : idptr;
X
Xvar    i    : toknidx;
X
X    procedure dig(n : integer);
X    begin
X        if n > 0 then
X            begin
X            dig(n div 10);
X            if i = maxtoknlen then
X                error(eoverflow);
X            t[i] := chr(n mod 10 + ord('0'));    (* CHAR *)
X            i := i + 1
X            end
X    end;
X
Xbegin
X    i := 1;
X    while t[i] <> chr(null) do
X        i := i + 1;
X    varno := varno + 1;
X    dig(varno);
X    t[i] := chr(null);
X    mkuniqname := saveid(t)
Xend;
X
X(*    Make a new unique variable with given char as prefix.        *)
Xfunction mkvariable(c : char) : idptr;
X
Xvar    t    : toknbuf;
X
Xbegin
X    t[1] := c;
X    t[2] := chr(null);
X    mkvariable := mkuniqname(t)
Xend;
X
X(*    Make a new unique variable with given char as prefix and    *)
X(*    with a given id as tail. Commonly used for renaming id's.    *)
Xfunction mkrename(c : char; ip : idptr) : idptr;
X
Xbegin
X    mkrename := mkconc(uscore, mkvariable(c), ip)
Xend;
X
X(*    Make a name for a variant. Variants are mapped onto C unions,    *)
X(*    which we always give the name "U", thus the name of the variant    *)
X(*    becomes "U.Vnnn" where "nnn" is a unique number.        *)
Xfunction mkvrnt : idptr;
X
Xvar    t    : toknbuf;
X
Xbegin
X    t[1] := 'U';
X    t[2] := '.';
X    t[3] := 'V';
X    t[4] := chr(null);
X    mkvrnt := mkuniqname(t)
Xend;
X
Xprocedure checksymbol(ss : symset);
Xbegin
X    if not (currsym.st in ss) then
X        error(ebadsymbol);
Xend;
X
X(*    Lexical analysis routine.                    *)
X(*    This procedure reads and classifies the next lexical token in    *)
X(*    the input stream. The token is saved in the global variable    *)
X(*    "currsym". The found symbol should be one of the symbols given    *)
X(*    in the parameter "ss" otherwise the error routine is called.    *)
Xprocedure nextsymbol(ss : symset);
X
Xvar    lastchr    : 0 .. maxtoknlen;
X
X    (*    This function reads the next character from the input    *)
X    (*    and updates "lineno" and "colno" accordingly.        *)
X    function nextchar : char;
X
X    var    c    : char;
X
X    begin
X        if eof then
X            c := chr(null)
X        else begin
X            colno := colno + 1;
X            if eoln then
X                begin
X                lineno := lineno + 1;
X                colno := 0
X                end;
X            read(c);
X            if echo then
X                if colno = 0 then
X                    writeln
X                else
X                    write(c);
X            if c = tab1 then
X                colno := ((colno div tabwidth) + 1) * tabwidth
X             end;
X        if lastchr > 0 then
X            begin
X            lasttok[lastchr] := c;
X            lastchr := lastchr + 1
X            end;
X        nextchar := c
X    end;
X
X    (*    This function looks at the next input character.    *)
X    function peekchar : char;
X
X    begin
X        if eof then
X            peekchar := chr(null)
X        else
X            peekchar := input^
X    end;
X
X    (*    Read and classify the next token.            *)
X    procedure nexttoken(realok : boolean);
X
X    var    c    : char;
X        n    : integer;
X
X        ready    : boolean;
X
X        wl    : toknidx;
X        wb    : toknbuf;
X
X        (*    Determine if c is valid in an identifier.    *)
X        (*    This function assumes a machine collating    *)
X        (*    sequence where letters and digits form conti-    *)
X        (*    gous sequences, CHAR.                *)
X        function idchar(c : char) : boolean;
X
X        begin
X            idchar :=
X                (c >= 'a') and (c <= 'z') or
X                    (c >= '0') and (c <= '9') or
X                    (c >= 'A') and (c <= 'Z') or
X                        (c = uscore)
X        end;
X
X        (*    Determine if c is valid in a number. CHAR.    *)
X        function numchar(c : char) : boolean;
X
X        begin
X            numchar := (c >= '0') and (c <= '9')
X        end;
X
X        (*    Convert a digit to its numeric value. CHAR    *)
X        function numval(c : char) : integer;
X
X        begin
X            numval := ord(c) - ord('0')
X        end;
X
X        (*    Determine if the current token is a keyword.    *)
X        function keywordcheck(var w : toknbuf; l : toknidx) : symtyp;
X
X        var    n    : 1 .. keywordlen;
X            i, j, k    : 0 .. keytablen;
X            wrd    : keyword;
X            kwc    : symtyp;
X
X        begin
X            (* quick check on token length,
X               pascal keywords range from 2 to 9 chars in length *)
X            if (l > 1) and (l < keywordlen) then
X                begin
X                (* could be a keyword, initialize wrd *)
X                wrd := keytab[keytablen].wrd;
X                (* copy w to wrd *)
X                for n := 1 to l do
X                    wrd[n] := w[n];
X
X                (* binary search for tokn,
X                   relies on symtyp being sorted *)
X                i := 0;
X                j := keytablen;
X                while j > i do
X                    begin
X                    k := (i + j) div 2;
X                    if keytab[k].wrd >= wrd then
X                        j := k
X                    else
X                        i := k + 1
X                    end;
X                if keytab[j].wrd = wrd then
X                    kwc := keytab[j].sym
X                else
X                    kwc := sid
X                end
X            else
X                kwc := sid;
X            keywordcheck := kwc
X        end;
X
X    begin    (* nexttoken *)
X        (* don't save blanks/comments *)
X        lastchr := 0;
X        (* read non-blank character *)
X        repeat
X            c := nextchar;
X            (* skip comments, the two comment delimiters of pascal
X               are treated as different if "diffcomm" is true *)
X            if c = '{' then
X                begin
X                repeat
X                    c := nextchar;
X                    if diffcomm then
X                        ready := c = '}'
X                    else
X                        ready := ((c = '*') and
X                                (peekchar = ')'))
X                            or (c = '}')
X                until ready or eof;
X                if eof and not ready then
X                    error(eeofcmnt);
X                if (c = '*') and not eof then
X                    c := nextchar;
X                c := space
X                end
X            else if (c = '(') and (peekchar = '*')  then
X                begin
X                c := nextchar;
X                repeat
X                    c := nextchar;
X                    if diffcomm then
X                        ready := (c = '*') and
X                            (peekchar = ')')
X                    else
X                        ready := ((c = '*') and
X                                (peekchar = ')'))
X                            or (c = '}')
X                until ready or eof;
X                if eof and not ready then
X                    error(eeofcmnt);
X                if (c = '*') and not eof then
X                    c := nextchar;
X                c := space
X                end
X        until    (c <> space) and (c <> tab1);
X
X        (* save characters from this token and save line- and column-
X           numbers for errormessages *)
X        lasttok[1] := c;
X        lastchr := 2;
X        lastcol := colno;
X        lastline := lineno;
X
X        (* map all CHAR control characters onto "badchr" *)
X        if c < okchr then
X            c := badchr;
X
X        (* decode symbol *)
X        with currsym do
X            if eof then
X            begin
X                lasttok[1] := '*';
X                lasttok[2] := 'E';
X                lasttok[3] := 'O';
X                lasttok[4] := 'F';
X                lasttok[5] := '*';
X                lastchr := 6;
X                st := seof
X            end
X            else
X            case c of
X
X
X            (* CHAR, chars not in Pascal *)
X              '|', '`', '~', '}',
X              bslash, uscore, badchr:
X                error(ebadchar);
X
X            (* identifiers or keywords *)
X              'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
X              'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
X              'u', 'v', 'w', 'x', 'y', 'z',
X              'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
X              'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
X              'U', 'V', 'W', 'X', 'Y', 'Z':
X                begin
X                (* read token into buffer *)
X                wb[1] := lowercase(c);
X                wl := 2;
X                while (wl < maxtoknlen) and idchar(peekchar) do
X                    begin
X                    wb[wl] := lowercase(nextchar);
X                    wl := wl + 1
X                    end;
X                if wl >= maxtoknlen then
X                    begin
X                    lasttok[lastchr] := chr(null);
X                    error(elongtokn)
X                    end;
X                (* terminate token and match *)
X                wb[wl] := chr(null);
X                (* check if keyword/identifier *)
X                st := keywordcheck(wb, wl-1);
X                if st = sid then
X                    vid := saveid(wb)
X                end;
X
X            (* integer or real numbers *)
X              '0', '1', '2', '3', '4', '5', '6', '7' ,'8', '9':
X                begin
X                (* assume integer number, save it in buffer *)
X                wb[1] := c;
X                wl := 2;
X                n := numval(c);
X                while numchar(peekchar) do
X                    begin
X                    c := nextchar;
X                    n := n * 10 + numval(c);
X                    wb[wl] := c;
X                    wl := wl + 1
X                    end;
X                st := sinteger;
X                vint := n;
X                if realok then
X                    begin
X                    (* accept real numbers *)
X                    if peekchar = '.' then
X                        begin
X                        (* this is a real number *)
X                        st := sreal;
X                        wb[wl] := nextchar;
X                        wl := wl + 1;
X                        while numchar(peekchar) do
X                            begin
X                            wb[wl] := nextchar;
X                            wl := wl + 1
X                            end
X                        end;
X                    c := peekchar;
X                    if (c = 'e') or (c = 'E') then
X                        begin
X                        (* this is a real number *)
X                        st := sreal;
X                        c := nextchar;
X                        wb[wl] := xpnent;
X                        wl := wl + 1;
X                        c := peekchar;
X                        if (c = '-') or (c = '+') then
X                            begin
X                            wb[wl] := nextchar;
X                            wl := wl + 1
X                            end;
X                        while numchar(peekchar) do
X                            begin
X                            wb[wl] := nextchar;
X                            wl := wl + 1
X                            end
X                        end;
X                    if st = sreal then
X                        begin
X                        wb[wl] := chr(null);
X                        vflt := savestr(wb)
X                        end
X                    end
X                end;
X
X              '(':
X                if peekchar = '.' then
X                    begin
X                    (* some compilers on non-ascii systems
X                       use (. for [ and .) for ] *)
X                    c := nextchar;
X                    st := slbrack
X                    end
X                else
X                    st := slpar;
X              ')':
X                st := srpar;
X              '[':
X                st := slbrack;
X              ']':
X                st := srbrack;
X              '.':
X                if peekchar = '.' then
X                    begin
X                    c := nextchar;
X                    st := sdotdot
X                    end
X                else if peekchar = ')' then
X                    begin
X                    c := nextchar;
X                    st := srbrack
X                    end
X                else
X                    st := sdot;
X              ';':
X                st := ssemic;
X              ':':
X                if peekchar = '=' then
X                    begin
X                    c := nextchar;
X                    st := sassign
X                    end
X                else
X                    st := scolon;
X              ',':
X                st := scomma;
X              '@',
X              '^':
X                st := sarrow;
X              '=':
X                st := seq;
X              '<':
X                if peekchar = '=' then
X                    begin
X                    c := nextchar;
X                    st := sle
X                    end
X                else if peekchar = '>' then
X                    begin
X                    c := nextchar;
X                    st := sne
X                    end
X                else
X                    st := slt;
X              '>':
X                if peekchar = '=' then
X                    begin
X                    c := nextchar;
X                    st := sge
X                    end
X                else
X                    st := sgt;
X              '+':
X                st := splus;
X              '-':
X                st := sminus;
X              '*':
X                st := smul;
X              '/':
X                st := squot;
X              quote:
X                begin
X                (* assume the symbol is a literal string *)
X                wl := 0;
X                ready := false;
X                repeat
X                    if eoln then
X                        begin
X                        lasttok[lastchr] := chr(null);
X                        error(ebadstring)
X                        end;
X                    c := nextchar;
X                    if c = quote then
X                        if peekchar = quote then
X                            c := nextchar
X                        else
X                            ready := true;
X                    if c = chr(null) then
X                        begin
X                        if eof then
X                            error(eeofstr);
X                        lasttok[lastchr] := chr(null);
X                        error(enulchr)
X                        end;
X                    if not ready then
X                        begin
X                        wl := wl + 1;
X                        if wl >= maxtoknlen then
X                            begin
X                            lasttok[lastchr] :=
X                                chr(null);
X                            error(elongstring)
X                            end;
X                        wb[wl] := c
X                        end
X                until    ready;
X                if wl = 1 then
X                    begin
X                    (* only 1 character => not a string *)
X                    st := schar;
X                    vchr := wb[1]
X                    end
X                else begin
X                    (* > 1 character => its a string *)
X                    wl := wl + 1;
X                    if wl >= maxtoknlen then
X                        begin
X                        lasttok[lastchr] := chr(null);
X                        error(elongstring)
X                        end;
X                    wb[wl] := chr(null);
X                    st := sstring;
X                    vstr := savestr(wb)
X                     end
X                end
X
X            end;(* case *)
X        if lastchr = 0 then
X            lastchr := 1;
X        lasttok[lastchr] := chr(null)
X    end;    (* nexttoken *)
X
Xbegin    (* nextsymbol *)
X    nexttoken(sreal in ss);
X    checksymbol(ss)
Xend;    (* nextsymbol *)
X
X(*    Return a pointer to the node describing the type of tp. This    *)
X(*    function also stores the result in the node for future ref.    *)
Xfunction typeof(tp : treeptr) : treeptr;
X
Xvar    tf, tq    : treeptr;
X
Xbegin
X    tq := tp;
X    tf := tq^.ttype;
X    (* keep working until a type is found *)
X    while tf = nil do
X        begin
X        case tq^.tt of
X          nchar:
X            tf := typnods[tchar];
X
X          ninteger:
X            tf := typnods[tinteger];
X
X          nreal:
X            tf := typnods[treal];
X
X          nstring:
X            tf := typnods[tstring];
X
X          nnil:
X            tf := typnods[tnil];
X
X          nid:
X            begin
X            tq := idup(tq);
X            if tq = nil then
X                fatal(etree)
X            end;
X
X          ntype,
X          nvar,
X          nconst,
X          nfield,
X          nvalpar,
X          nvarpar:
X            tq := tq^.tbind;
X
X          npredef,
X          nptr,
X          nscalar,
X          nrecord,
X          nconfarr,
X          narray,
X          nfileof,
X          nsetof:
X            tf := tq;    (* these nodetypes represent types *)
X
X          nsubrange:
X            if tq^.tup^.tt = nconfarr then
X                tf := tq^.tup^.tindtyp
X            else
X                tf := tq;
X
X          ncall:
X            begin
X            tf := typeof(tq^.tcall);
X            if tf = typnods[tpoly] then
X                tf := typeof(tq^.taparm)
X            end;
X
X          nfunc:
X            tq := tq^.tfuntyp;
X
X          nparfunc:
X            tq := tq^.tpartyp;
X
X          nproc,
X          nparproc:
X            tf := typnods[tnone];
X
X          nvariant,
X          nlabel,
X          npgm,
X          nempty,
X          nbegin,
X          nlabstmt,
X          nassign,
X          npush,
X          npop,
X          nif,
X          nwhile,
X          nrepeat,
X          nfor,
X          ncase,
X          nchoise,
X          ngoto,
X          nwith,
X          nwithvar:
X            fatal(etree);
X
X          nformat,
X          nrange:
X            tq := tq^.texpl;
X
X          nplus,
X          nminus,
X          nmul:
X            begin
X            tf := typeof(tq^.texpl);
X            if tf = typnods[tinteger] then
X                tf := typeof(tq^.texpr)
X            else if tf^.tt = nsetof then
X                tf := typnods[tset]
X            end;
X
X          numinus,
X          nuplus:
X            tq := tq^.texps;
X
X          nmod,
X          ndiv:
X            tf := typnods[tinteger];
X
X          nquot:
X            tf := typnods[treal];
X
X          neq,
X          nne,
X          nlt,
X          nle,
X          ngt,
X          nge,
X          nin,
X          nor,
X          nand,
X          nnot:
X            tf := typnods[tboolean];
X
X          nset:
X            tf := typnods[tset];
X
X          nselect:
X            tq := tq^.tfield;
X
X          nderef:
X            begin
X            tq := typeof(tq^.texps);
X            case tq^.tt of
X              nptr:
X                tq := tq^.tptrid;
X              nfileof:
X                tq := tq^.tof;
X              npredef:
X                tf := typnods[tchar]    (* textfile *)
X            end (* case *)
X            end;
X
X          nindex:
X            begin
X            tq := typeof(tq^.tvariable);
X            if tq^.tt = nconfarr then
X                tq := tq^.tcelem
X            else if tq = typnods[tstring] then
X                tf := typnods[tchar]
X            else
X                tq := tq^.taelem
X            end;
X
X        end (* case *)
X    end;
X    if tp^.ttype = nil then
X        tp^.ttype := tf;    (* remember type for future reference *)
X    typeof := tf
Xend;    (* typeof *)
X
X(*    Connect all nodes to their fathers.                *)
Xprocedure linkup(up, tp : treeptr);
X
Xbegin
X    while tp <> nil do
X        begin
X        if tp^.tup = nil then
X            begin
X            tp^.tup := up;
X            case tp^.tt of
X              npgm,
X              nfunc,
X              nproc:
X                begin
X                linkup(tp, tp^.tsubid);
X                linkup(tp, tp^.tsubpar);
X                linkup(tp, tp^.tfuntyp);
X                linkup(tp, tp^.tsublab);
X                linkup(tp, tp^.tsubconst);
X                linkup(tp, tp^.tsubtype);
X                linkup(tp, tp^.tsubvar);
X                linkup(tp, tp^.tsubsub);
X                linkup(tp, tp^.tsubstmt)
X                end;
X
X
X              nvalpar,
X              nvarpar,
X              nconst,
X              ntype,
X              nfield,
X              nvar:
X                begin
X                linkup(tp, tp^.tidl);
X                linkup(tp, tp^.tbind)
X                end;
X
X              nparproc,
X              nparfunc:
X                begin
X                linkup(tp, tp^.tparid);
X                linkup(tp, tp^.tparparm);
X                linkup(tp, tp^.tpartyp)
X                end;
X
X              nptr:
X                linkup(tp, tp^.tptrid);
X              nscalar:
X                linkup(tp, tp^.tscalid);
X
X              nsubrange:
X                begin
X                linkup(tp, tp^.tlo);
X                linkup(tp, tp^.thi)
X                end;
X              nvariant:
X                begin
X                linkup(tp, tp^.tselct);
X                linkup(tp, tp^.tvrnt)
X                end;
X              nrecord:
X                begin
X                linkup(tp, tp^.tflist);
X                linkup(tp, tp^.tvlist)
X                end;
X              nconfarr:
X                begin
X                linkup(tp, tp^.tcindx);
X                linkup(tp, tp^.tcelem);
X                linkup(tp, tp^.tindtyp)
X                end;
X              narray:
X                begin
X                linkup(tp, tp^.taindx);
X                linkup(tp, tp^.taelem)
X                end;
X              nfileof,
X              nsetof:
X                linkup(tp, tp^.tof);
X              nbegin:
X                linkup(tp, tp^.tbegin);
X              nlabstmt:
X                begin
X                linkup(tp, tp^.tlabno);
X                linkup(tp, tp^.tstmt)
X                end;
X              nassign:
X                begin
X                linkup(tp, tp^.tlhs);
X                linkup(tp, tp^.trhs)
X                end;
X              npush,
X              npop:
X                begin
X                linkup(tp, tp^.tglob);
X                linkup(tp, tp^.tloc);
X                linkup(tp, tp^.ttmp)
X                end;
X              ncall:
X                begin
X                linkup(tp, tp^.tcall);
X                linkup(tp, tp^.taparm )
X                end;
X              nif:
X                begin
X                linkup(tp, tp^.tifxp);
X                linkup(tp, tp^.tthen);
X                linkup(tp, tp^.telse)
X                end;
X              nwhile:
X                begin
X                linkup(tp, tp^.twhixp);
X                linkup(tp, tp^.twhistmt)
X                end;
X              nrepeat:
X                begin
X                linkup(tp, tp^.treptstmt);
X                linkup(tp, tp^.treptxp)
X                end;
X              nfor:
X                begin
X                linkup(tp, tp^.tforid);
X                linkup(tp, tp^.tfrom);
X                linkup(tp, tp^.tto);
X                linkup(tp, tp^.tforstmt)
X                end;
X              ncase:
X                begin
X                linkup(tp, tp^.tcasxp);
X                linkup(tp, tp^.tcaslst);
X                linkup(tp, tp^.tcasother)
X                end;
X              nchoise:
X                begin
X                linkup(tp, tp^.tchocon);
X                linkup(tp, tp^.tchostmt)
X                end;
X              nwith:
X                begin
X                linkup(tp, tp^.twithvar);
X                linkup(tp, tp^.twithstmt)
X                end;
X              nwithvar:
X                linkup(tp, tp^.texpw);
X              nindex:
X                begin
X                linkup(tp, tp^.tvariable);
X                linkup(tp, tp^.toffset)
X                end;
X              nselect:
X                begin
X                linkup(tp, tp^.trecord);
X                linkup(tp, tp^.tfield)
X                end;
X
X              ngoto:
X                linkup(tp, tp^.tlabel);
X
X              nrange, nformat,
X              nin, neq,
X              nne, nlt, nle,
X              ngt, nge, nor,
X              nplus, nminus,
X              nand, nmul,
X              ndiv, nmod,
X              nquot:
X                begin
X                linkup(tp, tp^.texpl);
X                linkup(tp, tp^.texpr)
X                end;
X
X              nderef,
X              nnot, nset,
X              numinus,
X              nuplus:
X                linkup(tp, tp^.texps);
X
X              nid,
X              nnil, ninteger,
X              nreal, nchar,
X              nstring, npredef,
X              nlabel, nempty:
X                (* no op *)
X            end (* case *)
X        end;
X        tp := tp^.tnext
X        end
Xend;    (* linkup *)
X
X(*    Allocate a new symbol node.                    *)
Xfunction mksym(vt : ltypes) : symptr;
X
Xvar    mp    : symptr;
X
Xbegin
X    new(mp);
X    if mp = nil then
X        error(enew);
X    mp^.lt := vt;
X    mp^.lnext := nil;
X    mp^.lsymdecl := nil;
X    mp^.ldecl := nil;
X    mksym := mp
Xend;
X
X(*    Enter a symbol at current declarationlevel.            *)
Xprocedure declsym(sp : symptr);
X
Xvar    h    : hashtyp;
X
Xbegin
X    if sp^.lt in [lpredef, lidentifier, lfield, lforward, lpointer] then
X        h := sp^.lid^.ihash
X    else
X        h := hashmax;
X    sp^.lnext := symtab^.ddecl[h];
X    symtab^.ddecl[h] := sp;
X    sp^.ldecl := symtab
Xend;
X
X(*    Create a node of selected type.                    *)
Xfunction mknode(nt : treetyp) : treeptr;
X
Xvar    tp    : treeptr;
X
Xbegin
X    tp := nil;
X    case nt of
X      npredef:    new(tp, npredef);
X      npgm:        new(tp, npgm);
X      nfunc:    new(tp, nfunc);
X      nproc:    new(tp, nproc);
X      nlabel:    new(tp, nlabel);
X      nconst:    new(tp, nconst);
X      ntype:    new(tp, ntype);
X      nvar:        new(tp, nvar);
X      nvalpar:    new(tp, nvalpar);
X      nvarpar:    new(tp, nvarpar);
X      nparproc:    new(tp, nparproc);
X      nparfunc:    new(tp, nparfunc);
X      nsubrange:    new(tp, nsubrange);
X      nvariant:    new(tp, nvariant);
X      nfield:    new(tp, nfield);
X      nrecord:    new(tp, nrecord);
X      nconfarr:    new(tp, nconfarr);
X      narray:    new(tp, narray);
X      nfileof:    new(tp, nfileof);
X      nsetof:    new(tp, nsetof);
X      nbegin:    new(tp, nbegin);
X      nptr:        new(tp, nptr);
X      nscalar:    new(tp, nscalar);
X      nif:        new(tp, nif);
X      nwhile:    new(tp, nwhile);
X      nrepeat:    new(tp, nrepeat);
X      nfor:        new(tp, nfor);
X      ncase:    new(tp, ncase);
X      nchoise:    new(tp, nchoise);
X      ngoto:    new(tp, ngoto);
X      nwith:    new(tp, nwith);
X      nwithvar:    new(tp, nwithvar);
X      nempty:    new(tp, nempty);
X      nlabstmt:    new(tp, nlabstmt);
X      nassign:    new(tp, nassign);
X      nformat:    new(tp, nformat);
X      nin:        new(tp, nin);
X      neq:        new(tp, neq);
X      nne:        new(tp, nne);
X      nlt:        new(tp, nlt);
X      nle:        new(tp, nle);
X      ngt:        new(tp, ngt);
X      nge:        new(tp, nge);
X      nor:        new(tp, nor);
X      nplus:    new(tp, nplus);
X      nminus:    new(tp, nminus);
X      nand:        new(tp, nand);
X      nmul:        new(tp, nmul);
X      ndiv:        new(tp, ndiv);
X      nmod:        new(tp, nmod);
X      nquot:    new(tp, nquot);
X      nnot:        new(tp, nnot);
X      numinus:    new(tp, numinus);
X      nuplus:    new(tp, nuplus);
X      nset:        new(tp, nset);
X      nrange:    new(tp, nrange);
X      nindex:    new(tp, nindex);
X      nselect:    new(tp, nselect);
X      nderef:    new(tp, nderef);
X      ncall:    new(tp, ncall);
X      nid:        new(tp, nid);
X      nchar:    new(tp, nchar);
X      ninteger:    new(tp, ninteger);
X      nreal:    new(tp, nreal);
X      nstring:    new(tp, nstring);
X      nnil:        new(tp, nnil);
X      npush:    new(tp, npush);
X      npop:        new(tp, npop);
X      nbreak:    new(tp, nbreak)
X    end;(* case *)
X    if tp = nil then
X        error(enew);
X    tp^.tt := nt;
X    tp^.tnext := nil;
X    tp^.tup := nil;
X    tp^.ttype := nil;
X    mknode := tp
Xend;
X
X(*    Create a node with a literal value.                *)
Xfunction mklit : treeptr;
X
Xvar    sp    : symptr;
X    tp    : treeptr;
X
Xbegin
X    case currsym.st of
X      sinteger:
X        begin
X        sp := mksym(linteger);
X        sp^.linum := currsym.vint;
X        tp := mknode(ninteger);
X        end;
X      sreal:
X        begin
X        sp := mksym(lreal);
X        sp^.lfloat := currsym.vflt;
X        tp := mknode(nreal);
X        end;
X      schar:
X        begin
X        sp := mksym(lcharacter);
X        sp^.lchar := currsym.vchr;
X        tp := mknode(nchar);
X        end;
X      sstring:
X        begin
X        sp := mksym(lstring);
X        sp^.lstr := currsym.vstr;
X        tp := mknode(nstring);
X        end
X    end;(* case *)
X    tp^.tsym := sp;
X    sp^.lsymdecl := tp;
X    mklit := tp
Xend;
X
X(*    Look up an identifier among declared symbols.            *)
Xfunction lookupid(ip : idptr; fieldok : boolean) : symptr;
X
Xlabel    999;
X
Xvar    sp    : symptr;
X    dp    : declptr;
X    vs    : set of ltypes;
X
Xbegin
X    lookupid := nil;
X    if fieldok then
X        vs := [lidentifier, lforward, lpointer, lfield]
X    else
X        vs := [lidentifier, lforward, lpointer];
X    sp := nil;
X
X    (* pick up symboltable from innermost scope *)
X    dp := symtab;
X    while dp <> nil do
X        begin
X        (* scan linked symbols with same hasvalue *)
X        sp := dp^.ddecl[ip^.ihash];
X        while sp <> nil do
X            begin
X            (* break out when proper id found *)
X            if (sp^.lt in vs) and (sp^.lid = ip) then
X                goto 999;
X            sp := sp^.lnext
X            end;
X        (* proceed to enclosing scope *)
X        dp := dp^.dprev
X        end;
X999:
X    lookupid := sp
Xend;
X
X(*    Look up a label.                        *)
Xfunction lookuplabel(i : integer) : symptr;
X
Xlabel    999;
X
Xvar    sp    : symptr;
X    dp    : declptr;
X
Xbegin
X    sp := nil;
X    dp := symtab;
X    while dp <> nil do
X        begin
X        sp := dp^.ddecl[hashmax];
X        while sp <> nil do
X            begin
X            if (sp^.lt in [lforwlab, llabel]) and (sp^.lno = i) then
X                goto 999;
X            sp := sp^.lnext
X            end;
X        dp := dp^.dprev
X        end;
X999:
X    lookuplabel := sp
Xend;
X
X(*    Create a new declaration level (a new scope) link declnode to    *)
X(*    previous node.    dp is non-nil when a procedure/function body    *)
X(*    is encountered for which we have seen a forward declaration.     *)
Xprocedure enterscope(dp : declptr);
X
Xvar    h    : hashtyp;
X
Xbegin
X    if dp = nil then
X        begin
X        new(dp);
X        for h := 0 to hashmax do
X            dp^.ddecl[h] := nil
X        end;
X    dp^.dprev := symtab;
X    symtab := dp
Xend;
X
X(*    Return current scope (as a pointer to symbol-table).    *)
Xfunction currscope : declptr;
X
Xbegin
X    currscope := symtab
Xend;
X
X(*    Drop innermost declaration scope.                *)
Xprocedure leavescope;
X
Xbegin
X    symtab := symtab^.dprev
Xend;
X
X(*    Create a new identifier symbol.                    *)
Xfunction mkid(ip : idptr) : symptr;
X
Xvar    sp    : symptr;
X
Xbegin
X    sp := mksym(lidentifier);
X    sp^.lid := ip;
X    sp^.lused := false;
X    declsym(sp);
X    ip^.inref := ip^.inref + 1;
X    mkid := sp
Xend;
X
X(*    Check that the current identifier is new then save it in the    *)
X(*    current scope. Create and return a new node representing this    *)
X(*    instance of the identifier.                    *)
Xfunction newid(ip : idptr) : treeptr;
X
Xvar    sp    : symptr;
X    tp    : treeptr;
X
Xbegin
X    sp := lookupid(ip, false);
X    if sp <> nil then
X        if sp^.ldecl <> symtab then
X            sp := nil;
X    if sp = nil then
X        begin
X        (* new identifier *)
X        tp := mknode(nid);
X        sp := mkid(ip);
X        sp^.lsymdecl := tp;
X        tp^.tsym := sp
X        end
X    else if sp^.lt = lpointer then
X        begin
X        (* previously declared as a pointer type *)
X        tp := mknode(nid);
X        tp^.tsym := sp;
X        sp^.lt := lidentifier;
X        sp^.lsymdecl := tp
X        end
X    else if sp^.lt = lforward then
X        begin
X        (* previously forward declared *)
X        sp^.lt := lidentifier;
X        tp := sp^.lsymdecl
X        end
X    else
X        error(emultdeclid);
X    newid := tp
Xend;
X
X(*    Check that the current identifier is already declared,    *)
X(*    we fail unless l in [lforward, lpointer].        *)
X(*    Create and return a new node referencing it.        *)
Xfunction oldid(ip : idptr; l : ltypes) : treeptr;
X
Xvar    sp    : symptr;
X    tp    : treeptr;
X
Xbegin
X    sp := lookupid(ip, true);
X    if sp = nil then
X        begin
X        if l in [lforward, lpointer] then
X            begin
X            tp := newid(ip);
X            tp^.tsym^.lt := l
X            end
X        else
X            error(enotdeclid)
X        end
X    else begin
X        sp^.lused := true;
X        tp := mknode(nid);
X        tp^.tsym := sp;
X        if (sp^.lt = lpointer) and (l = lidentifier) then
X            begin
X            sp^.lt := lidentifier;
X            sp^.lsymdecl := tp
X            end
X         end;
X    oldid := tp
Xend;
X
X(*    Look up a field in a record declaration.            *)
X(*    Return nil if field isn't declared in "tp" or its variants.    *)
Xfunction oldfield(tp : treeptr; ip : idptr) : treeptr;
X
Xlabel    999;
X
Xvar    tq, ti,
X    fp    : treeptr;
X
Xbegin
X    fp := nil;
X    tq := tp^.tflist;
X    while tq <> nil do
X        begin
X        ti := tq^.tidl;
X        while ti <> nil do
X            begin
X            if ti^.tsym^.lid = ip then
X                begin
X                fp := mknode(nid);
X                fp^.tsym := ti^.tsym;
X                goto 999
X                end;
X            ti := ti^.tnext
X            end;
X        tq := tq^.tnext
X        end;
X    tq := tp^.tvlist;
X    while tq <> nil do
X        begin
X        fp := oldfield(tq^.tvrnt, ip);
X        if fp <> nil then
X            tq := nil
X        else
X            tq := tq^.tnext
X        end;
X999:
X    oldfield := fp
Xend;
X
X(*    This is the main parsing routine. It parses a correct pascal-    *)
X(*    program and builds a parsetree which is left in the global    *)
X(*    variable top.                            *)
X(*    Parsing is done through recursive descent using a set of    *)
X(*    mutually recursive functions.                    *)
Xprocedure parse;
X
X    function plabel : treeptr;                forward;
X    function pidlist(l : ltypes) : treeptr;            forward;
X    function pconst : treeptr;                forward;
X    function pconstant(realok : boolean) : treeptr;        forward;
X    function precord(cs : symtyp; dp : declptr) : treeptr;    forward;
X    function ptypedef : treeptr;                forward;
X    function ptype : treeptr;                forward;
X    function pvar : treeptr;                forward;
X    function psubs : treeptr;                forward;
X    function psubpar : treeptr;                forward;
X    function plabstmt : treeptr;                forward;
X    function pstmt : treeptr;                forward;
X    function psimple : treeptr;                forward;
X    function pvariable(varptr : treeptr) : treeptr;        forward;
X    function pexpr(tnp : treeptr) : treeptr;        forward;
X    function pcase : treeptr;                forward;
X    function pif : treeptr;                    forward;
X    function pwhile : treeptr;                forward;
X    function prepeat : treeptr;                forward;
X    function pfor : treeptr;                forward;
X    function pwith : treeptr;                forward;
X    function pgoto : treeptr;                forward;
X    function pbegin(retain : boolean) : treeptr;        forward;
X
X    (*    Open scope of a record variable.            *)
X    procedure scopeup(tp : treeptr);
X
X        (*    Scan a record-declaration and add all fields to    *)
X        (*    current scope.                    *)
X        procedure addfields(rp : treeptr);
X
X        var    fp, ip, vp    : treeptr;
X            sp        : symptr;
X
X        begin
X            fp := rp^.tflist;
X            while fp <> nil do
X                begin
X                ip := fp^.tidl;
X                while ip <> nil do
X                    begin
X                    sp := mksym(lfield);
X                    sp^.lid := ip^.tsym^.lid;
X                    sp^.lused := false;
X                    sp^.lsymdecl := ip;
X                    declsym(sp);
X                    ip := ip^.tnext
X                    end;
X                fp := fp^.tnext
X                end;
X            vp := rp^.tvlist;
X            while vp <> nil do
X                begin
X                addfields(vp^.tvrnt);
X                vp := vp^.tnext
X                end
X        end;
X    begin
X        addfields(typeof(tp))
X    end;
X
X    (*    Check that the current label is new then save it in the    *)
X    (*    current scope. Create and return a new node referencing    *)
X    (*    the label.                        *)
X    function newlbl : treeptr;
X
X    var    sp    : symptr;
X        tp    : treeptr;
X
X    begin
X        tp := mknode(nlabel);
X        sp := lookuplabel(currsym.vint);
X        if sp <> nil then
X            if sp^.ldecl <> symtab then
X                sp := nil;
X        if sp = nil then
X            begin
X            sp := mksym(lforwlab);
X            sp^.lno := currsym.vint;
X            sp^.lgo := false;
X            sp^.lsymdecl := tp;
X            declsym(sp)
X            end
X        else
X            error(emultdecllab);
X        tp^.tsym := sp;
X        newlbl := tp
X    end;
X
X    (*    Check that the current label is already declared.    *)
X    (*    Create and return a new node referencing it.        *)
X    function oldlbl(defpt : boolean) : treeptr;
X
X    var    sp    : symptr;
X        tp    : treeptr;
X
X    begin
X        sp := lookuplabel(currsym.vint);
X        if sp = nil then
X            begin
X            prtmsg(enotdecllab);
X            tp := newlbl;
X            sp := tp^.tsym
X            end
X        else begin
X            tp := mknode(nlabel);
X            tp^.tsym := sp
X             end;
X        if defpt then
X            begin
X
END_OF_FILE
if test 59347 -ne `wc -c <'ptc.p.1'`; then
    echo shar: \"'ptc.p.1'\" unpacked with wrong size!
fi
# end of 'ptc.p.1'
fi
echo shar: End of archive 12 \(of 12\).
cp /dev/null ark12isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 12 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]